SPACE 1/SPACE - Library 1 - Volume 1.iso/utilitys/81/spiro.lst

File List | 1987-09-03 | 6.3 KB | 423 lines

' ST Applications Dec.1986 pag 10
Titlew 2,"ST APPLICATIONS SPIROGRAPH"
Fullw 2
Clearw 2
Color 1
Dim Red(15),Blue(15),Green(15)
Rinc=0.5
Size:
Sizex=0
Sizey=0
Angle=1
Swcolor$="normal"
If Xbios(4)=2 Then
  Res=2
Else
  Res=1
Endif
Gosub Switch_background_color
Swcolor$="revers"
Type$="1"
M$="There are five|types of spirographs.|Hit the mouse button|after picture is finished"
Alert 3,M$,1,"OK|Quit",C
If C=2 Then
  Gosub Restore_color
  End
Else
  M$="Enter the type of|spirograph you want"
  Alert 2,M$,0,"Spiro|Sine|Pies",C
Endif
If C=1 Then
  M$="Enter the type of Spiro"
  Alert 2,M$,0,"#1|#2|#3",C
  Type=C
Else
  Type=C+2
Endif
Gosub Get_angle
M$="What color background|color do you want"
Alert 2,M$,0,"White|Black",C
If C=1 Then
  Bkg=7
Else
  Bkg=0
Endif
If Res=2 Then
  Gosub Switch_background_color
  Swcolor$="normal"
  Clearw 2
  K=2
  Goto Ang
Endif
M$="Enter color range"
Alert 2,M$,0,"Earth|Rainbow",C
K=4
Clearw 2
Gosub Switch_background_color
Swcolor$="normal"
On C Gosub Col310,Col430
Goto Col550
Procedure Col310
  Red(4)=2
  Blue(4)=7
  Green(4)=7
  Col320:
  Red(5)=0
  Blue(5)=7
  Green(5)=7
  Col330:
  Red(6)=0
  Blue(6)=5
  Green(6)=6
  Red(7)=0
  Blue(7)=3
  Green(7)=6
  Col350:
  Red(8)=0
  Blue(8)=1
  Green(8)=6
  Col360:
  Red(9)=3
  Blue(9)=2
  Green(9)=6
  Col370:
  Red(10)=4
  Blue(10)=1
  Green(10)=6
  Col380:
  Red(11)=5
  Blue(11)=0
  Green(11)=4
  Col390:
  Red(12)=6
  Blue(12)=0
  Green(12)=6
  Col400:
  Red(13)=7
  Blue(13)=0
  Green(13)=5
  Col410:
  Red(14)=7
  Blue(14)=2
  Green(14)=6
  Col420:
  Red(15)=7
  Blue(15)=4
  Green(15)=6
Return
Goto Col550
Procedure Col430
  Red(4)=7
  Blue(4)=5
  Green(4)=0
  Col440:
  Red(5)=7
  Blue(5)=4
  Green(5)=0
  Col450:
  Red(6)=0
  Blue(6)=7
  Green(6)=0
  Col460:
  Red(7)=0
  Blue(7)=7
  Green(7)=5
  Col470:
  Red(8)=0
  Blue(8)=7
  Green(8)=7
  Col480:
  Red(9)=0
  Blue(9)=5
  Green(9)=7
  Col490:
  Red(10)=0
  Blue(10)=2
  Green(10)=7
  Col500:
  Red(11)=0
  Blue(11)=0
  Green(11)=7
  Col510:
  Red(12)=5
  Blue(12)=0
  Green(12)=7
  Col520:
  Red(13)=7
  Blue(13)=0
  Green(13)=7
  Col530:
  Red(14)=7
  Blue(14)=0
  Green(14)=4
  Col540:
  Red(15)=7
  Blue(15)=0
  Green(15)=2
Return
Col550:
For Col=4 To 15
  R=Red(Col)
  B=Blue(Col)
  G=Green(Col)
  Gosub Newcolor
Next Col
Ang:
Deffn A(Angle)=Angle*3.1428/180
R=1
Xo=0
Yo=0
Xoo=0
Yoo=0
K=1
Poke 226560,1
If Type=4 Then
  Gosub Four
  Goto Sou
Endif
If Type=5 Then
  Gosub Five
  Goto Sou
Endif
Startspiro:
If Res=1 Then
  K=K+1
  If K>15 Then
    K=4
  Endif
Else
  K=2
Endif
Color K
Deftext 1,,,
Deffill K,2,8
On Type Gosub One,Two,Three
Angle=Angle+A
If Angle>360 Then
  Angle=Angle-360
Endif
R=R+Rinc
If R>150 Then
  Goto Sou
Endif
Goto Startspiro
Sou:
Sound 1,14,2,3,5
Sound 1,0,0,0,0
Poke 226560,0
B=0
Eloop:
If B>0 Then
  Goto Size
Endif
Gosub Getmouse
Goto Eloop
End
Procedure Newcolor
  R=R*142
  G=G*142
  B=B*142
  Setcolor Col,R,G,B
Return
Procedure Switch_background_color
  If Swcolor$="normal" Then
    Col=1
    R=0
    G=0
    B=7
    Gosub Newcolor
    Col=3
    R=0
    G=0
    B=7
    Gosub Newcolor
    Col=2
    R=0
    G=3
    B=7
    Gosub Newcolor
    Col=0
    R=7
    G=7
    B=7
    Gosub Newcolor
  Else
    Col=1
    R=7
    G=7
    B=7
    Gosub Newcolor
    Col=3
    R=7
    G=7
    B=7
    Gosub Newcolor
    Col=0
    R=Bkg
    G=Bkg
    B=Bkg
    Gosub Newcolor
  Endif
Return
Procedure One
  X=R*Sin(Fn A(Angle))+Xo
  X0=R*Sin(Fn A(Angle))
  Y=R*Cos(Fn A(Angle))+Yo
  Yo=R*Cos(Fn A(Angle))
  Line Res*(152),85,Res*(Xo+152),Yo+85
  Line Res*(152+Xo),85+Yo,Res*(X+152),Y+85
  Line Res*(152+X),85+Y,Res*(152),85
Return
Procedure Two
  X=R*Sin(Fn A(Angle))+Xo
  Xo=R*Sin(Fn A(Angle))
  Y=R*Cos(Fn A(Angle))+Yo
  Yo=R*Cos(Fn A(Angle))
  Line Res*(152+Xo),85+Yo,Res*(X+152),Y+85
Return
Procedure Three
  Xn=(R*Sin(Fn A(Angle)))
  Yn=(R*Cos(Fn A(Angle)))
  Line Res*(152+Xoo),(85+Yoo),Res*(Xn+152),(Yn+85)
  Xoo=(R*Sin(Fn A(Angle))+Xn)
  Yoo=(R*Cos(Fn A(Angle))+Yn)
Return
Procedure Four
  Xres=609
  Yres=186
  Size=4
  C=2
  If Res=1 Then
    Xres=305
    C=4
    Size=2
  Endif
  Sinamp=(Rnd(9)*200)
  Cosamp=(Rnd(9)*200)
  Sinper=(Rnd(9)*100)
  Cosper=(Rnd(9)*100)
  For Xpoint=0 To Xres Step Size
    If Res=1 Then
      Color C
      C=C+1
      If C=16 Then
        C=4
      Endif
    Else
      Color 2
    Endif
    Siney=(Sin(Xpoint/Sinper)*Sinamp)+(Yres/2)
    Cosey=(Cos(Xpoint/Cosper)*Cosamp)+(Yres/2)
    Line Xpoint,Siney,Xres-Xpoint,Cosey
  Next Xpoint
Return
Procedure Five
  If Res=1 Then
    Maxcol=15
    Mincol=4
  Else
    Maxcol=3
    Mincol=2
  Endif
  K=Mincol
  L=150*Res
  M=85
  D=300*Res
  If A<20 Then
    Innc=300
  Endif
  If A>19 Then
    Innc=6000/A
  Endif
  Eangle=A*10
  Bangle=0
  For Z=1 To Innc
    Color K
    Deffill K,,
    Deftext 1,,,,
    Pcircle L,M,D,Bangle,Eangle
    K=K+1
    If K>Maxcol Then
      K=Mincol
    Endif
    Bangle=Eangle
    Eangle=Bangle+A*10
  Next Z
Return
Procedure Getmouse
  B=Mousek
  Mx=Mousex
  My=Mousey
  If B>0 Then
    Sound 1,9,2,5,5
    Sound 1,0,0,0,0
  Endif
Return
Procedure Get_angle
  Clearw 2
  Line 10,80,250,80
  Line 70,80,70,85
  Line 130,80,130,85
  Line 10,80,10,85
  Line 190,80,190,85
  Line 250,80,250,85
  Text 0,10," 0      90     180    270     360"
  Restart:
  Gosub Getmouse
  If Mx<10 Then
    Mx=10
    If Mx>250 Then
      Mx=250
    Endif
  Endif
  Print At(9,12);"angel =",Int((Mx-10)*3/2),"  "
  Deftext 0,,,
  Deffill 0,,
  Color 0
  Line Omx,60,Omx,79
  Line Omx,79,Omx+3,76
  Line Omx,79,Omx-3,76
  Deftext 2,,,
  Deffill 2,,
  Color 2
  Line Mx,79,Mx+3,76
  Line Mx,79,Mx-3,76
  Line Mx,60,Mx,79
  Omx=Mx
  Deftext 1,,,
  Deffill 1,,
  Color 1
  If B=0 Then
    Goto Restart
  Endif
  A=Int((Mx-10)*3/2)
Return
Procedure Restore_color
  Col=1
  R=0
  G=0
  B=0
  Gosub Re_color
  Col=3
  R=0
  G=0
  B=0
  Gosub Re_color
  Col=2
  R=0
  G=0
  B=7
  Gosub Re_color
  Col=0
  R=7
  G=7
  B=7
  Gosub Re_color
Return
Procedure Re_color
  R=R*1
  G=G*1
  B=B*1
  Setcolor Col,R,G,B
Return